home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / 2.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  7KB  |  229 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #include "hdr.h"
  10. #include "vars.h"
  11. #include "libhdr.h"
  12. #include "dclmapp.h"
  13. #include "libp.h"
  14. #include "errmsgp.h"
  15. #include "miscp.h"
  16. #include "smiscp.h"
  17. #include "setp.h"
  18. #include "chapp.h"
  19.  
  20. void process_pragma(Node node)                                /*;process_pragma*/
  21. {
  22.     /* This arbitrarily extensible procedure  processes pragma declarations.
  23.      * The name  of the  pragma  determines the way     in which the  args  are
  24.      * processed. If no meaning has been attached to a pragma name, the user
  25.      * is notified, and the pragma is ignored.
  26.      */
  27.  
  28.     Node    id_node, arg_list_node, arg_node, i_node, e_node, arg1, arg2;
  29.     Node    priority, marker_node, type_node;
  30.     char    *id;
  31.     Tuple    args, arg_list;
  32.     Symbol    proc_name, p_type, id_sym;
  33.     int        nat, exists, newnat;
  34.     Fortup    ft1;
  35.     Forset    fs1;
  36.  
  37.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : process_pragma(node) ");
  38.  
  39.     id_node = N_AST1(node);
  40.     arg_list_node = N_AST2(node);
  41.     id = N_VAL(id_node);
  42.     arg_list = N_LIST(arg_list_node);
  43.     /*aix := []; */ /* Most pragmas generate no code.*/
  44.     if (is_empty(arg_list)) {    /* pragma with no parameters */
  45.         errmsg_str("Format error in pragma", id, "Appendices B, F", node);
  46.     }
  47.     else {
  48.         /* Process list of arguments. */
  49.         args = tup_new(0);
  50.         FORTUP(arg_node = (Node), arg_list, ft1);
  51.             i_node = N_AST1(arg_node);
  52.             e_node = N_AST2(arg_node);
  53.             adasem(e_node);
  54.             /* For now, disregard named associations.*/
  55.             args = tup_with(args, (char *) e_node);
  56.         ENDFORTUP(ft1);
  57.  
  58.         if (streq(id, "IO_INTERFACE") ) {
  59.             /* Current interface to predefined procedures (e.g. text_io).
  60.              * The pragma makes up the body of a predefined procedure.
  61.              * This body is formatted into a single tuple :
  62.              *
  63.              *        [ io_subprogram, marker , name1, name2...]
  64.              *
  65.              * where the marker is the  second argument  of the  pragma. This
  66.              * marker is  used as an     internal switch by the tio interpreter.
  67.              * The remaining components of  the tuple are the unique names of
  68.              * the formal parameters of the procedure.The pragma must follow
  69.              * immediately the procedure spec to which it applies. The pragma
  70.              * then supplies the body for it.
  71.              */
  72.             arg1 = (Node) args[1];
  73.             /* The first argument in the pragma list is a string in the case
  74.              * of overloadable operators used in the CALENDAR package.
  75.              */
  76.             if (N_KIND(arg1) == as_string_literal)
  77.                 id = N_VAL(arg1);
  78.             else
  79.                 id = N_VAL(N_AST1(arg1));
  80.             /* assert exists proc_name in overloads(declared(scope_name)(id))
  81.              *  | rmatch(nature(proc_name), '_spec') /= om;
  82.              */
  83.             exists = FALSE;
  84.             FORSET(proc_name = (Symbol),
  85.               OVERLOADS(dcl_get(DECLARED(scope_name), id)), fs1);
  86.                 nat = NATURE(proc_name);
  87.                 if (nat == na_procedure_spec  || nat == na_function_spec
  88.                   || nat == na_task_obj_spec || nat == na_generic_procedure_spec
  89.                   || nat == na_generic_function_spec 
  90.                   || nat == na_generic_package_spec) {
  91.                     exists = TRUE;
  92.                     break;
  93.                 }
  94.             ENDFORSET(fs1);
  95.             if (exists == FALSE)
  96.                 warning("subprogram given in pragma not found", node);
  97.             if (nat == na_procedure_spec  ) newnat = na_procedure;
  98.             else if (nat == na_function_spec) newnat = na_function;
  99.             else warning("argument to pragma is not a subprogram", node);
  100.             NATURE(proc_name) = newnat;
  101.             marker_node = N_AST1((Node)args[2]);
  102.             if (tup_size(args) == 3 ) {
  103.                 type_node = (Node)args[3];
  104.                 find_old(type_node);
  105.             }
  106.             else
  107.                 type_node = OPT_NODE;
  108.             N_KIND(node) = as_predef;
  109.             N_UNQ(node) = proc_name;
  110.             /* marker_node is an as_line_no node which carries the numerical 
  111.              * predef code corresponding to the entry in the pragma 
  112.               * IO_INTERFACE. as_line_no was used to simpify having the predef 
  113.              * code converted into a number by the parser and relayed here 
  114.              * as an integer.
  115.              */
  116.             N_VAL(node) = N_VAL(marker_node);
  117.             N_TYPE(node) = (type_node == OPT_NODE)? OPT_NAME : N_UNQ(type_node);
  118.         }
  119.         else if (streq(id, "INTERFACE") ) {
  120.             /* Current interface to C and FORTRAN 
  121.              * The pragma makes up the body of a procedure.
  122.              * This body is formatted into a single tuple :
  123.              *
  124.              *        [language, name]
  125.              *
  126.              * where language is C or FORTRAN and name is the identifier 
  127.              * of the subprogram to be interfaced.
  128.              * This pragma is allowed at the place of a declarative item of
  129.              * the same declarative part or package specification. The pragma 
  130.              * is also allowed for a library unit; in this case, the pragma must
  131.              * appear after the subprogram decl, and before any subsequent
  132.              * compilation unit. 
  133.              */
  134.             arg1 = (Node) args[1];
  135.             /* The 1st arg in the pragma list is an identifier (C or FORTRAN) */
  136.             if (N_KIND(arg1) != as_name) {
  137.                 warning("invalid format for pragma", node);
  138.                 return;
  139.             }
  140.             id = N_VAL(N_AST1(arg1));
  141.             if (!streq(id, "C") && !streq(id, "FORTRAN")) {
  142.                 warning("invalid first argument for pragma", node);
  143.                 return;
  144.             }
  145.  
  146.             arg2 = (Node) args[2];
  147.             /* The 2nd argument in the pragma list is a subprogram identifier */
  148.             if (N_KIND(arg2) != as_name) {
  149.                 warning("invalid format for pragma", node);
  150.                 return;
  151.             }
  152.             id = N_VAL(N_AST1(arg2));
  153.             /* assert exists proc_name in overloads(declared(scope_name)(id))
  154.              *  | rmatch(nature(proc_name), '_spec') /= om;
  155.              */
  156.             exists = FALSE;
  157.             id_sym = dcl_get(DECLARED(scope_name), id);
  158.             if (id_sym == (Symbol)0) {
  159.                 if (NATURE(scope_name)== na_private_part)
  160.                     /* check parent scope, which is scope of visible part */
  161.                     id_sym = dcl_get(DECLARED((Symbol)open_scopes[2]), id);
  162.                 if (id_sym == (Symbol)0) {
  163.                     warning("subprogram given in pragma not found", node);
  164.                     return;
  165.                 }
  166.             }
  167.             FORSET(proc_name = (Symbol), OVERLOADS(id_sym), fs1);
  168.                 nat = NATURE(proc_name);
  169.                 if (nat == na_procedure_spec) {
  170.                     newnat = na_procedure;
  171.                     exists = TRUE;
  172.                 }
  173.                 else if (nat == na_function_spec) {
  174.                     newnat = na_function;
  175.                     exists = TRUE;
  176.                 }
  177.             ENDFORSET(fs1);
  178.             if (!exists) {
  179.                 warning("invalid second argument to pragma", node);
  180.                 return;
  181.             }
  182.  
  183.             NATURE(proc_name) = newnat;
  184.             N_KIND(node) = as_interfaced;
  185.             N_UNQ(node) = proc_name;
  186.             N_AST1(node) = N_AST1(arg1);
  187.         }
  188.  
  189.         else if (streq(id, "PRIORITY")) {
  190.             Unitdecl ud;
  191.             if (tup_size(args) == 1) {
  192.                 ud = unit_decl_get("spSYSTEM");
  193.                 if (ud == (Unitdecl)0 || !in_vis_mods(ud->ud_unam) ) {
  194.                     warning(
  195.       "use of PRIORITY without presence of package SYSTEM is ignored",
  196.                       (Node)args[1]);
  197.                     N_KIND(node) = as_opt;
  198.                     N_AST1(node) = N_AST2(node) = N_AST3(node) = N_AST4(node)
  199.                       = (Node)0;
  200.                     return;
  201.                 }
  202.                 else {
  203.                     p_type = dcl_get_vis(DECLARED(ud->ud_unam), "PRIORITY");
  204.                 }
  205.                 priority = (Node) args[1];
  206.                 check_type(p_type, priority);
  207.                 if (!is_static_expr(priority))
  208.                     warning("Priority must be static", priority);
  209.             }
  210.             else
  211.                 warning("Invalid format for pragma priority", node);
  212.         }
  213.         else if (streq(id, "CONTROLLED")
  214.           || streq(id, "INCLUDE")
  215.           || streq(id, "INLINE")
  216.           || streq(id, "LIST")
  217.           || streq(id, "MEMORY_SIZE")
  218.           || streq(id, "OPTIMIZE")
  219.           || streq(id, "PACK")
  220.           || streq(id, "STORAGE_UNIT")
  221.           || streq(id, "SUPRESS")
  222.           || streq(id, "SYSTEM") ) {
  223.             warning("unsupported pragma", id_node);
  224.         }
  225.         else
  226.             warning("unrecognized pragma", node);
  227.     }
  228. }
  229.